home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / msdos / raytrace / pov / gen / bstone / sample / tetra.bas < prev    next >
Encoding:
BASIC Source File  |  1994-04-20  |  8.6 KB  |  253 lines
  1. 10      REM          *** A Blob of Tetrahedrons & Octahedrons ***
  2. 20      REM 
  3. 30      REM     The principle: you have two rooms, one filled with cells
  4. 40      REM     made of two tetras and and one octa, the other one filled with
  5. 50      REM     the normal cubes. You transform a point from the tetra space
  6. 60      REM     into the normal space. After that you calculate if this point
  7. 70      REM     belongs to the blob storing this information with the original
  8. 80      REM     (tetra-) coordinates. In a second loop you draw the tetras &
  9. 90      REM     octas depending on the status of their corner points.
  10. 100     REM 
  11. 110     REM     (The idea comes from another M.C. Escher picture;
  12. 120     REM     I could not find a translation of its title in my dictionary.
  13. 130     REM     In German it is called "Plattwurmer")
  14. 140     REM 
  15. 150     REM    Init the size of the tetra space, scaling constant
  16. 160     LET SIZE=24
  17. 170     LET DT=0.05
  18. 180     LET SIZ2=SIZE/2
  19. 190     REM    Allocate memory for the tetra space: bit field
  20. 200     DIM  BIT BF[SIZE][SIZE][SIZE]
  21. 210     REM    Allocate memory for corner points of tetra space: vector field
  22. 220     DIM CP^[4]
  23. 230     REM    Create the right-hand coordinate system of tetra space
  24. 240     LET SX^=VX
  25. 250     LET SY^=<0.5,0,SQRT(3)/2>
  26. 260     LET SZ^=<0.5,-SQRT(2/3),0.5/SQRT(3)>
  27. 270     LET XX^=-SZ^
  28. 280     LET YY^=SX^-SZ^
  29. 290     LET ZZ^=SY^-SZ^
  30. 300     LET CP^[1]= TRANSFORM (<-1,1,-1>,XX^,YY^,ZZ^)
  31. 310     LET CP^[2]= TRANSFORM (<-1,1,1>,XX^,YY^,ZZ^)
  32. 320     LET CP^[3]= TRANSFORM (<1,1,-1>,XX^,YY^,ZZ^)
  33. 330     LET CP^[4]= TRANSFORM (<1,1,1>,XX^,YY^,ZZ^)
  34. 340     REM    Calculate the angle-dependent norming constant for tetra space:
  35. 350     REM    It is the maximum expansion of the tetra space in X,Y or Z
  36. 360     REM    direction.
  37. 370     LET TSCALE=0
  38. 380     FOR I=1 TO 4
  39. 390     IF VX(CP^[I])>TSCALE THEN TSCALE=VX(CP^[I])
  40. 400     IF VY(CP^[I])>TSCALE THEN TSCALE=VY(CP^[I])
  41. 410     IF VZ(CP^[I])>TSCALE THEN TSCALE=VZ(CP^[I])
  42. 420     NEXT I
  43. 430     LET TS=TSCALE/SIZ2
  44. 440     PRINT "Overhead factor ca.",TSCALE
  45. 450     REM 
  46. 460     REM    The loop: calculate the setting information and store it into
  47. 470     REM    the bit field. Points not fitting into the normal 1,1,1 cube
  48. 480     REM    are not considered.
  49. 490     REM 
  50. 500     FOR Z=1 TO SIZE
  51. 510     FOR Y=1 TO SIZE
  52. 520     FOR X=1 TO SIZE
  53. 530     GOSUB 2230
  54. 540     GOSUB 2300
  55. 550     NEXT X
  56. 560     NEXT Y
  57. 570     PRINT "*"
  58. 580     NEXT Z
  59. 590     REM 
  60. 600     REM    Define two tetras and one octa using the XX^,YY^,ZZ^
  61. 610     REM    (Thus, you can create "distorted" tetras & octas using
  62. 620     REM     your own definitions for these vectors)
  63. 630     REM 
  64. 640     PRINT "Tetrahedrons & Octahedrons"
  65. 650     DELETE TX1$
  66. 660     LET TX1$="MyTex1"
  67. 670     DELETE TX2$
  68. 680     LET TX2$="MyTex2"
  69. 690     DELETE TX3$
  70. 700     LET TX3$="MyTex3"
  71. 710     LET A^=V0
  72. 720     LET B^=XX^
  73. 730     LET C^=YY^
  74. 740     LET D^=ZZ^
  75. 750     GOSUB 1470
  76. 760     LET TETRA_A$=TETRA$
  77. 770     TEX TETRA_A$=TX1$
  78. 780     LET A^=YY^+ZZ^
  79. 790     LET B^=XX^+YY^+ZZ^
  80. 800     LET C^=XX^+ZZ^
  81. 810     LET D^=XX^+YY^
  82. 820     GOSUB 1470
  83. 830     LET TETRA_B$=TETRA$
  84. 840     TEX TETRA_B$=TX2$
  85. 850     LET A^=YY^
  86. 860     LET B^=XX^+YY^
  87. 870     LET C^=YY^+ZZ^
  88. 880     LET D^=XX^
  89. 890     LET E^=ZZ^
  90. 900     LET F^=XX^+ZZ^
  91. 910     GOSUB 1730
  92. 920     TEX OCTA$=TX3$
  93. 930     DELETE "tetra.inc"
  94. 940     LET T_A$="Tetra_A"
  95. 950     REM    Calculate bounding shapes for 2 tetras & 1 octa
  96. 960     REM    and save the declarations
  97. 970     BOUND T_A$= BOUND TETRA_A$
  98. 980     DELETE  BOUND TETRA_A$
  99. 990     LET T_B$="Tetra_B"
  100. 1000    BOUND T_B$= BOUND TETRA_B$
  101. 1010    DELETE  BOUND TETRA_B$
  102. 1020    LET OCT$="Octa"
  103. 1030    BOUND OCT$= BOUND OCTA$
  104. 1040    DELETE  BOUND OCTA$
  105. 1050    FPRINT "#declare Tetra_A = ",TETRA_A$
  106. 1060    FPRINT "#declare Tetra_B = ",TETRA_B$
  107. 1070    FPRINT "#declare Octa = ",OCTA$
  108. 1080    REM 
  109. 1090    REM    Evaluate setting information and write the tetra & octa grid
  110. 1100    REM    The PXXX points contain the corner information of one
  111. 1110    REM    cell of the tetra space
  112. 1120    REM 
  113. 1130    PRINT "Writing Crystal"
  114. 1140    FOR Z=1 TO SIZE-1
  115. 1150    FOR Y=1 TO SIZE-1
  116. 1160    LET FLAG=0
  117. 1170    FOR X=1 TO SIZE-1
  118. 1180    LET P010= BIT BF[X][Y+1][Z]
  119. 1190    LET P011= BIT BF[X][Y+1][Z+1]
  120. 1200    IF !(P010||P011) THEN  GOTO 1300
  121. 1210    LET P000= BIT BF[X][Y][Z]
  122. 1220    LET P001= BIT BF[X][Y][Z+1]
  123. 1230    LET P100= BIT BF[X+1][Y][Z]
  124. 1240    LET P101= BIT BF[X+1][Y][Z+1]
  125. 1250    LET P110= BIT BF[X+1][Y+1][Z]
  126. 1260    LET P111= BIT BF[X+1][Y+1][Z+1]
  127. 1270    IF P000&&P100&&P001&&P010 THEN  GOSUB 2090
  128. 1280    IF P110&&P011&&P101&&P111 THEN  GOSUB 2110
  129. 1290    IF P001&&P010&&P011&&P100&&P101&&P110 THEN  GOSUB 2130
  130. 1300    NEXT X
  131. 1310    IF !FLAG THEN  GOTO 1360
  132. 1320    BOUND A$
  133. 1330    FPRINT A$
  134. 1340    DELETE A$
  135. 1350    LET FLAG=0
  136. 1360    REM   
  137. 1370    NEXT Y
  138. 1380    PRINT "Step: ",Z
  139. 1390    NEXT Z
  140. 1400    END 
  141. 1410    REM 
  142. 1420    REM 
  143. 1430    REM    Sub-routines
  144. 1440    REM 
  145. 1450    REM 
  146. 1460    REM  
  147. 1470    REM         Tetrahedron
  148. 1480    LET T1$=PLANE(A^,B^,C^)
  149. 1490    LET T2$=PLANE(A^,C^,D^)
  150. 1500    LET T3$=PLANE(A^,D^,B^)
  151. 1510    LET T4$=PLANE(B^,D^,C^)
  152. 1520    LET P1$=PLANE(A^+DT*(C^-A^),(A^-B^)#(D^-C^))
  153. 1530    LET P2$=PLANE(A^+DT*(D^-A^),(A^-C^)#(B^-D^))
  154. 1540    LET P3$=PLANE(A^+DT*(B^-A^),(A^-D^)#(C^-B^))
  155. 1550    LET P4$=PLANE(B^+DT*(D^-B^),(C^-B^)#(A^-D^))
  156. 1560    LET P5$=PLANE(B^+DT*(C^-B^),(B^-D^)#(A^-C^))
  157. 1570    LET P6$=PLANE(C^+DT*(B^-C^),(C^-D^)#(B^-A^))
  158. 1580    LET M^=1/4*(A^+B^+C^+D^)
  159. 1590    LET RAD=ABS(M^-A^)
  160. 1600    IF ABS(M^-B^)>RAD THEN RAD=ABS(M^-B^)
  161. 1610    IF ABS(M^-C^)>RAD THEN RAD=ABS(M^-C^)
  162. 1620    IF ABS(M^-D^)>RAD THEN RAD=ABS(M^-D^)
  163. 1630    DELETE BD$
  164. 1640    LET BD$="sphere { <0,0,0> 1 }"
  165. 1650    LET BD$=SCALE(BD$,<RAD,RAD,RAD>)
  166. 1660    LET BD$=TRANSLATE(BD$,M^)
  167. 1670    LET TETRA$=SECT(T1$,T2$,T3$,T4$,P1$,P2$,P3$,P4$,P5$,P6$)
  168. 1680    BOUND TETRA$=BD$
  169. 1690    RETURN 
  170. 1700    REM 
  171. 1710    REM 
  172. 1720    REM  
  173. 1730    REM         Octahedron
  174. 1740    LET T1$=PLANE(A^,B^,C^)
  175. 1750    LET T2$=PLANE(D^,E^,F^)
  176. 1760    LET T3$=PLANE(A^,E^,D^)
  177. 1770    LET T4$=PLANE(E^,A^,C^)
  178. 1780    LET T5$=PLANE(C^,F^,E^)
  179. 1790    LET T6$=PLANE(F^,C^,B^)
  180. 1800    LET T7$=PLANE(B^,D^,F^)
  181. 1810    LET T8$=PLANE(D^,B^,A^)
  182. 1820    LET P1$=PLANE(A^+DT*(C^-A^),(A^-B^)#(D^-C^))
  183. 1830    LET P2$=PLANE(A^+DT*(D^-A^),(A^-C^)#(B^-E^))
  184. 1840    LET P3$=PLANE(A^+DT*(E^-A^),(A^-D^)#(E^-B^))
  185. 1850    LET P4$=PLANE(A^+DT*(B^-A^),(A^-E^)#(C^-D^))
  186. 1860    LET P5$=PLANE(B^+DT*(D^-B^),(B^-C^)#(F^-A^))
  187. 1870    LET P6$=PLANE(B^+DT*(F^-B^),(B^-D^)#(A^-F^))
  188. 1880    LET P7$=PLANE(B^+DT*(C^-B^),(B^-F^)#(D^-C^))
  189. 1890    LET P8$=PLANE(C^+DT*(F^-C^),(C^-E^)#(F^-A^))
  190. 1900    LET P9$=PLANE(C^+DT*(E^-C^),(C^-F^)#(B^-E^))
  191. 1910    LET PA$=PLANE(D^+DT*(F^-D^),(D^-E^)#(A^-F^))
  192. 1920    LET PB$=PLANE(D^+DT*(E^-D^),(D^-F^)#(E^-B^))
  193. 1930    LET PC$=PLANE(E^+DT*(C^-E^),(E^-F^)#(C^-D^))
  194. 1940    LET M^=1/6*(A^+B^+C^+D^+E^+F^)
  195. 1950    LET RAD=ABS(M^-A^)
  196. 1960    IF ABS(M^-B^)>RAD THEN RAD=ABS(M^-B^)
  197. 1970    IF ABS(M^-C^)>RAD THEN RAD=ABS(M^-C^)
  198. 1980    IF ABS(M^-D^)>RAD THEN RAD=ABS(M^-D^)
  199. 1990    IF ABS(M^-E^)>RAD THEN RAD=ABS(M^-E^)
  200. 2000    IF ABS(M^-F^)>RAD THEN RAD=ABS(M^-F^)
  201. 2010    DELETE BD$
  202. 2020    LET BD$="sphere { <0,0,0> 1}"
  203. 2030    LET BD$=SCALE(BD$,<RAD,RAD,RAD>)
  204. 2040    LET BD$=TRANSLATE(BD$,M^)
  205. 2050    LET OCTA$=SECT(T1$,T2$,T3$,T4$,T5$,T6$,T7$,T8$)
  206. 2060    LET OCTA$=SECT(OCTA$,P1$,P2$,P3$,P4$,P5$,P6$,P7$,P8$,P9$,PA$,PB$,PC$)
  207. 2070    BOUND OCTA$=BD$
  208. 2080    RETURN 
  209. 2090    LET B$=T_A$
  210. 2100    GOTO 2140
  211. 2110    LET B$=T_B$
  212. 2120    GOTO 2140
  213. 2130    LET B$=OCT$
  214. 2140    GOSUB 2230
  215. 2150    LET B$=SCALE(B$,<TS,TS,TS>)
  216. 2160    LET B$=BP^
  217. 2170    IF !FLAG THEN  GOTO 2200
  218. 2180    LET A$=ADDOBJ(A$,B$)
  219. 2190    RETURN 
  220. 2200    LET A$=B$
  221. 2210    LET FLAG=1
  222. 2220    RETURN 
  223. 2230    REM     Transformation
  224. 2240    LET FP^=TSCALE*(1/SIZ2*<X-1,Y-1,Z-1>-<1,1,1>)
  225. 2250    LET BP^= TRANSFORM #(FP^,XX^,YY^,ZZ^)
  226. 2260    RETURN 
  227. 2270    REM 
  228. 2280    REM 
  229. 2290    REM  
  230. 2300    REM   Blob function
  231. 2310    LET A=0
  232. 2320    IF ABS(VX(BP^))>1||ABS(VY(BP^))>1||ABS(VZ(BP^))>1 THEN  GOTO 2340
  233. 2330    GOSUB 2420
  234. 2340    BIT BF[X][Y][Z]=A
  235. 2350    RETURN 
  236. 2360    REM  Blob density function
  237. 2370    LET RR=ABS(BP^-C^)
  238. 2380    IF RR>RAD THEN  RETURN 
  239. 2390    LET DENS=DENS+STR*SQR(1-SQR(RR/RAD))
  240. 2400    RETURN 
  241. 2410    REM  Blob
  242. 2420    LET RAD=1
  243. 2430    LET STR=1
  244. 2440    LET DENS=0
  245. 2450    LET C^=<0.75,0,0>
  246. 2460    GOSUB 2370
  247. 2470    LET C^=<-0.375,0.64952,0>
  248. 2480    GOSUB 2370
  249. 2490    LET C^=<-0.375,-0.64952,0>
  250. 2500    GOSUB 2370
  251. 2510    LET A=DENS>=0.6
  252. 2520    RETURN 
  253.